home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The 640 MEG Shareware Studio 2
/
The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO
/
pascal
/
tpb4_src.zip
/
UPLOAD.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-09-13
|
17KB
|
520 lines
{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault
Last modified :: 9-10-88 11:01 am
}
{$R-} {Range checking off}
{$B-} {Boolean complete evaluation off}
{$S-} {Stack checking off}
{$I+} {I/O checking on}
{$N-} {No numeric coprocessor}
Unit Upload;
Interface
Uses
TPCrt, Dos, Globals, TPSTRING, TAccess,
TPDOS, Core1, Core2, Dirs, Sysop1;
procedure RecvXmodem(mode : Char);
{==========================================================================}
Implementation
procedure RecvXmodem(mode : Char);
{ Receive a file using Xmodem protocol }
var
filecount, i,
mm, ss : Integer;
free : LongInt;
Xfrname : DosFileName;
Abort_batch,
In_Conference,
timeup : Boolean;
bt : Byte;
XfrFile : untype_file;
TemDrv : Str3;
TemName,
DszMode : StrPr;
This : SectPtr;
protocol_ok : Boolean;
procedure Call_Dsz(var Xfrname : DosFileName;
var XfrFile : untype_file;
var mode : Char);
begin {Call_Dsz}
Str(rate, baud);
OK := True;
errcode := 0;
SetSect(HomName);
Ch_Wait;
ScrollOn;
case mode of
'C' :
DszMode := 'rx';
'X' :
DszMode := 'rc';
'Y' :
DszMode := 'rc -k';
'Z' :
DszMode := 'rz -y';
'Q' :
DszMode := 'rc -g';
'O' :
DszMode := 'ro';
end;
errcode := ExecDos(DSZPath+' handshake on '+DszMode+' '+RcvName+'\'
+Xfrname, False, nil);
if errcode = 0 then errcode := DosExitCode;
Ch_Init;
Ch_Set(rate);
ScrollOff;
WriteLn(Com);
SetSect(RcvName);
Assign(XfrFile, Xfrname);
{$I-}
Reset(XfrFile) {$I+} ; { Reopen file for return }
OK := (IoResult = 0); { OK true if file found }
if OK then OK := (FileSize(XfrFile) > 0);
if (not Ch_Carck) then
begin
errcode := 1;
SetSect(HomName);
log(12, 'recving file');
SetSect(RcvName);
mdhangup;
remote_online := False;
end;
if errcode <> 0 then
OK := False;
if OK then
begin
WriteLn(Com);
WriteLn(Com, 'Transfer sucessfully completed.');
end;
end; {Call_Dsz}
procedure Get_File(var Xfrname : DosFileName; mode : Char);
var
block, mm, ss : Integer;
i : LongInt;
file_exists : Boolean;
junk : DosFileName;
begin
if Xfrname <> '' then
begin
block := 1;
file_exists := False;
while (Length(Xfrname)-Pos('.', Xfrname)) < 2 do
Xfrname := Xfrname+'-';
SetSect(HomName);
case mode of
'Z' :
log(16, Xfrname);
'G' :
log(18, Xfrname)
else
log(4, Xfrname);
end;
junk := Xfrname;
FindKey(NewinName, i, junk); { Is it in the NEWIN file }
OK := (not OK);
if OK then { No, so check upload area }
begin
SetSect(RcvName);
Assign(XfrFile, Xfrname);
{$I-}
Reset(XfrFile) {$I+} ; { Try to open file }
OK := (IoResult <> 0);
end;
if OK then { Not in NEWIN file or upload area }
begin
{$I-}
Rewrite(XfrFile) {$I+} ; { Try to open file }
OK := (IoResult = 0);
if OK then
begin
Close(XfrFile);
Erase(XfrFile);
SetSect(HomName);
free := (diskfree(Ord(Upcase(RcvDrv[1]))-64)) div 1024;
WriteLn(Com);
Write(Com, 'File: ', Xfrname);
if In_Conference then
WriteLn(Com, ' will be received in this conference area.')
else
WriteLn(Com, ' will be received in a private area.');
WriteLn(Com, free, 'k disk space available.');
WriteLn(Com, 'Please cancel with Ctrl X''s if space is too small.');
WriteLn(Com);
WriteLn(Com, 'Ready to receive...');
WriteLn(Com);
SetSect(HomName);
Call_Dsz(Xfrname, XfrFile, mode);
if OK then
OK := (FileSize(XfrFile) > 0);
if OK then
begin
send_time(FileSize(XfrFile), mm, ss);
extra_time := extra_time+mm+1;
end;
Close(XfrFile);
if OK then
begin
if not In_Conference then
hide_release(Xfrname, private, RcvName);
end
else
begin
Erase(XfrFile);
WriteLn(Com);
WriteLn(Com, 'Transfer cancelled. Incomplete file deleted.');
end;
end
else
WriteLn(Com, 'Cannot create ', Xfrname, '.');
end
else
begin
WriteLn(Com, 'Thanks, but there is already a copy of ', Xfrname,
' online.');
file_exists := True
end;
SetSect(HomName);
if OK then
log(7, '')
else
begin
if file_exists then
log(8, 'File Exists')
else
log(8, '');
end;
end;
end;
procedure Get_description(Xfrname : DosFileName);
var
work : StrStd;
i : Integer;
rec : LongInt;
function get_section(mode : Char) : DosFileName;
var
This : SectPtr;
line_count,
conf_num : Integer;
work : DosFileName;
begin
abort := False;
repeat
This := SectBase;
WriteLn(Com);
work := prompt('Section name ', 12, 'ES?M');
if work = ' ' then
begin
work := 'NEWIN'; {DEFAULT VALUE}
WriteLn(Com, 'Defaulting to: NEWIN');
WriteLn(Com);
end;
if work = '?' then
begin
line_count := 2;
WriteLn(Com, 'Available File Sections:');
WriteLn(Com);
while (not brk) and (This <> nil) do
begin
conf_num := This^.SectConf;
if (user_rec.access >= This^.SectAccs) or (test_bit(user_rec.conf_flags,
conf_num)) then
begin
Write(Com, yellow, pad(This^.SectName, 14));
if mode = 'D' then
WriteLn(Com, green, This^.SectDesc, cyan)
else
WriteLn(Com, cyan);
end;
This := This^.next;
if user_rec.lines <> 99 then
begin
Inc(line_count);
if line_count mod user_rec.lines = 0 then
pause;
end;
end;
WriteLn(Com);
end;
This := SectBase;
while (This <> nil) and (This^.SectName <> work) do
This := This^.next;
until (work = This^.SectName) or (brk) or (not Online);
if work = This^.SectName then
get_section := work
else
get_section := 'NEWIN';
end;
begin {get_description}
repeat
WriteLn(Com, white, 'Please enter a one line description of your file:');
WriteLn(Com);
WriteLn(Com, green,
' |-------------------------------------------------------------------------|',
cyan);
work := prompt('', 75, 'EL');
WriteLn(Com);
until ((work <> '') and (ask('Is your description correct', 'Y'))) or (not Online);
WriteLn(Com, 'Enter Section Name where the file should be located.');
with nwin_rec do
begin
status := private;
PointValue := 0;
name := Xfrname;
GetTAD(date);
user := user_loc;
descr := work;
sectn := get_section('D');
dnloads := 0;
for i := 0 to 5 do
last_dnload[i] := 0;
end;
Seek(nwin_file, FileSize(nwin_file));
Write(nwin_file, nwin_rec);
rec := Pred(FileSize(nwin_file));
AddKey(NewinArea, rec, nwin_rec.sectn);
FlushIndex(NewinArea);
AddKey(NewinName, rec, nwin_rec.name);
FlushIndex(NewinName);
end;
begin { RecvXmodem }
if (not(mode in ['G', 'Q'])) then
protocol_ok := True
else if (not AllowMNP) then
protocol_ok := False
else if cmd_tail and (StUpcase(ParamStr(3)) = 'MNP') then
protocol_ok := (ParamStr(4) = '/Arq')
else if cmd_tail then
protocol_ok := True
else
protocol_ok := mnp;
if ((diskfree(Ord(Upcase(RcvDrv[1]))-64) div 1024) > maxfree_uplds) and protocol_ok then
begin
filecount := 0;
Abort_batch := False;
Xfrname := ' '; {set up}
In_Conference := False;
This := SectBase;
while (This <> nil) and (This^.SectName <> SectReq) do
This := This^.next;
if This^.SectName = SectReq then
begin
i := This^.SectConf; {conference number}
In_Conference := test_bit(user_rec.conf_flags, i)
end;
if In_Conference then
begin
TemDrv := RcvDrv;
TemName := RcvName;
RcvDrv := SetDrv;
RcvName := SetName;
end;
if (mode in ['B', 'Z', 'G']) then
begin
case mode of
'Z' :
log(16, Xfrname);
'G' :
log(18, Xfrname)
else
log(4, Xfrname);
end;
free := (diskfree(Ord(Upcase(RcvDrv[1]))-64)) div 1024;
WriteLn(Com);
WriteLn(Com, 'Batch Mode Enabled - ', free, 'K space available.');
WriteLn(Com, 'Please cancel with Ctrl X''s if space is too small.');
Write(Com, 'Files will be received in ');
if In_Conference then
WriteLn(Com, 'this conference area.')
else
WriteLn(Com, 'a private area.');
WriteLn(Com);
WriteLn(Com, white, 'Ready to Receive...');
WriteLn(Com, cyan);
Ch_Wait;
Delay(500);
Assign(ext_log, ZmdmLogName);
{$I-} ;
Reset(ext_log);
Close(ext_log);
{$I+} ;
if IoResult = 0 then
Erase(ext_log);
SetSect(RcvName);
Ch_Wait;
ScrollOn;
case mode of
'Z' :
DszMode := 'rz';
'B' :
DszMode := 'rb';
'G' :
DszMode := 'rb -g';
end;
errcode := ExecDos(DSZPath+' handshake on restrict '+DszMode, False, nil);
SetSect(HomName);
Delay(1500);
Ch_Init;
Ch_Set(rate);
ScrollOff;
WriteLn(Com);
Abort_batch := True;
Assign(ext_log, ZmdmLogName);
{$I-}
Reset(ext_log) {$I+} ;
if IoResult = 0 then
begin
while (not EoF(ext_log)) do
begin
ReadLn(ext_log, ext_log_rec);
if (not(ext_log_rec[1] in ['E', 'L', 'U'])) then
begin
Abort_batch := False;
Delete(ext_log_rec, 1, 50);
if Pos(' ', ext_log_rec) <> 0 then
Delete(ext_log_rec, Pos(' ', ext_log_rec), 10);
Xfrname := ext_log_rec;
for i := 1 to Length(Xfrname) do
Xfrname[i] := Upcase(Xfrname[i]);
WriteLn(Com, yellow, 'File: ', white, Xfrname, cyan);
if Online then
begin
Get_description(Xfrname);
SetSect(RcvName);
Assign(XfrFile, Xfrname);
{$I-}
Reset(XfrFile) {$I+} ;
OK := (IoResult = 0);
if OK then
begin
send_time(FileSize(XfrFile), mm, ss);
extra_time := extra_time+mm+1;
Close(XfrFile)
end;
SetSect(HomName);
end;
case mode of
'Z' :
log(16, Xfrname);
'G' :
log(18, Xfrname)
else
log(4, Xfrname);
end;
if not In_Conference then
hide_release(Xfrname, private, RcvName);
end;
end;
Close(ext_log);
end
else
begin
Delay(1000);
WriteLn(Com, 'Transfer aborted by sender or file already exits.')
end;
if (not Abort_batch) then
log(7, 'BATCH')
else
begin
log(8, 'BATCH');
WriteLn(Com, 'Aborting Zmodem Transfer.');
end;
if OK and (not Abort_batch) then
begin
WriteLn(Com, 'Thanks, ', UserFirstName, '.');
WriteLn(Com);
WriteLn(Com, 'Your upload(s) will be credited when approved by the Sysop.');
end;
SetSect(HomName);
if (SetDrv = RcvDrv) and (SetName = RcvName) then
begin
ReadDir(DirEntries, DirSpace, DirBase);
new_dir := False;
end;
end {END OF BATCH}
else
begin
Xfrname := prompt('File name', 12, 'ES');
if Xfrname <> ' ' then
Xfrname := correct_fn(Xfrname)
else
Xfrname := '';
if Xfrname <> '' then
Get_File(Xfrname, mode);
if OK and (Xfrname <> '') then
begin
WriteLn(Com);
WriteLn(Com, 'Transfer Complete.');
SetSect(HomName);
Get_description(Xfrname);
if (SetDrv = RcvDrv) and (SetName = RcvName) then
begin
ReadDir(DirEntries, DirSpace, DirBase);
new_dir := False;
end;
WriteLn(Com, 'Thanks, ', UserFirstName, '.');
WriteLn(Com, 'Your upload(s) will be credited when approved by the Sysop.');
end
else
Clear_inbuf;
end;
if In_Conference then
begin
RcvDrv := TemDrv;
RcvName := TemName;
In_Conference := False;
end;
SetSect(HomName);
end {got enough disk space}
else
begin
WriteLn(Com);
if (not protocol_ok) then
begin
WriteLn(Com, 'Sorry, that protocol requires an MNP connection.');
SetSect(HomName);
log(4, 'Not MNP');
end
else
WriteLn(Com, 'Not enough disk space for uploads.');
WriteLn(Com);
end;
repeat
bt := GetByte(2, timeup);
until timeup;
end;
end. { of UPLOAD.PAS }